home *** CD-ROM | disk | FTP | other *** search
/ The Business Master (3rd Edition) / The Business Master (3rd Edition).iso / files / commadio / freespch / phonemem.lzh / PHONEMEM.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1989-07-16  |  4.8 KB  |  142 lines
  1. PROGRAM PhoneMem;
  2.  
  3. USES CRT;
  4.  
  5. { ┌──────────────────────────────────────────────────────┬──────────────────┐
  6.   │ Pinnacle Software's  Phone Memory Mnemonic Assistant │     PHONEMEM     │
  7.   ├──────────────────────────────────────────────────────┴──────────────────┤
  8.   │  C O P Y R I G H T  (C)  1989  BY   P I N N A C L E    S O F T W A R E  │
  9.   │  P.O. Box  386, Town of Mount Royal, Montreal, Quebec, Canada  H3P 3C6  │
  10.   ├─────────────────────────────────────────────────────────────────────────┤
  11.   │  This program may be given to others, provided it is given in unalter-  │
  12.   │  ed form, including this notice, and that it is given absolutely free.  │
  13.   └─────────────────────────────────────────────────────────────────────────┘ }
  14.  
  15. TYPE
  16.   String2  = STRING[2];
  17.   String80 = STRING[80];
  18. VAR
  19.   AfterPointer : INTEGER;
  20.   Basic        : String80;
  21.   Equiv        : String2;
  22.   EquivAfter   : String2;
  23.   EquivPointer : INTEGER;
  24.   NumIn        : String80;
  25.   PairFound    : BOOLEAN;
  26.   PairPointer  : INTEGER;
  27.   Pointer      : INTEGER;
  28.   Reprint      : INTEGER;
  29.   Test         : CHAR;
  30.   TestAfter    : CHAR;
  31. CONST
  32.   NumNums   : String80 = '0123456789';
  33.   Equivs    : ARRAY[0..9] OF String2 =
  34.     ('NQ','LV','TZ','GW','XR','FC','DB','SJ','HK','MP');
  35.   NumPairs  = 65;
  36.   Pairs     : ARRAY[1..NumPairs] OF String2 =
  37.     ('BB','CC','DD','FF','LL','MM','NN','PP','RR','SS','TT','ZZ',
  38.      'BL','BR',
  39.      'CH','CK','CL','CR','CT',
  40.      'DR',
  41.      'FR','FL','FT',
  42.      'GR','GH','GL','GR',
  43.      'KN',
  44.      'LD','LK','LF',
  45.      'MP',
  46.      'NC','ND','NG','NK','NS','NT',
  47.      'PH','PL','PR',
  48.      'RB','RD','RG','RK','RL','RM','RN','RS','RT',
  49.      'SC','SH','SK','SL','SM','SN','SP','SQ','ST','SW',
  50.      'TH','TR','TW',
  51.      'WH','WR');
  52.  
  53. PROCEDURE TextInverseOn;
  54. BEGIN TEXTCOLOR(BLACK); TEXTBACKGROUND(LIGHTGRAY); END;
  55.  
  56. PROCEDURE TextInverseOff;
  57. BEGIN TEXTCOLOR(CYAN); TEXTBACKGROUND(BLACK); END;
  58.  
  59. BEGIN
  60.   CLRSCR;
  61.   TextInverseOff;
  62.   WRITELN;
  63.   WRITE('Enter the number that you want to remember:  ');
  64.   READLN(NumIn);
  65.   WRITELN;
  66.   {--- Delete non-numeric data ---}
  67.   IF LENGTH(NumIn) > 0 THEN
  68.   BEGIN
  69.     Pointer := 1;
  70.     REPEAT
  71.       IF POS(NumIn[Pointer],NumNums) = 0
  72.       THEN DELETE(NumIn,Pointer,1)
  73.       ELSE Pointer := Pointer + 1;
  74.     UNTIL Pointer > LENGTH(NumIn);
  75.     IF LENGTH(NumIn) > 0
  76.     THEN
  77.     BEGIN
  78.       WRITELN('The basic alternatives are as follows:');
  79.       WRITELN;
  80.       Basic := '';
  81.       FOR Pointer := 1 TO LENGTH(NumIn) DO
  82.       BEGIN
  83.         Equiv := Equivs[POS(NumIn[Pointer],NumNums)-1];
  84.         Basic := Basic + Equiv;
  85.         WRITE(Equiv,' ');
  86.       END;
  87.       IF LENGTH(Basic) > 2 THEN
  88.       BEGIN
  89.         WRITELN; WRITELN;
  90.         WRITELN('Letter pairs that typically occur in English...');
  91.         WRITELN;
  92.         PairFound := FALSE;
  93.         FOR Pointer := 1 TO (LENGTH(Basic)-1 DIV 2) DO
  94.         BEGIN
  95.           {----- Look for candidate ---}
  96.           Equiv      := Basic[Pointer*2-1] + Basic[Pointer*2];
  97.           EquivAfter := Basic[Pointer*2+1] + Basic[Pointer*2+2];
  98.           FOR PairPointer := 1 TO NumPairs DO
  99.           BEGIN
  100.             EquivPointer := 0;
  101.             AfterPointer := 0;
  102.             Test         := Pairs[PairPointer][1];
  103.             TestAfter    := Pairs[PairPointer][2];
  104.             IF Test      = Equiv[1]      THEN EquivPointer := 1;
  105.             IF Test      = Equiv[2]      THEN EquivPointer := 2;
  106.             IF TestAfter = EquivAfter[1] THEN AfterPointer := 1;
  107.             IF TestAfter = EquivAfter[2] THEN AfterPointer := 2;
  108.             IF (EquivPointer <> 0) AND (AfterPointer <> 0) THEN
  109.             BEGIN
  110.               PairFound := TRUE;
  111.               FOR Reprint := 1 TO (LENGTH(Basic) DIV 2) DO
  112.               BEGIN
  113.                 IF (Reprint = Pointer) OR (Reprint = Pointer+1) THEN
  114.                 BEGIN
  115.                   IF Reprint = Pointer THEN
  116.                   BEGIN
  117.                     TextInverseOn;
  118.                     WRITE(Test,' ');
  119.                     TextInverseOff;
  120.                   END
  121.                   ELSE
  122.                   BEGIN
  123.                     TextInverseOn;
  124.                     WRITE(TestAfter,' ');
  125.                     TextInverseOff;
  126.                   END;
  127.                 END   { Highlight this }
  128.                 ELSE WRITE(Basic[Reprint*2-1],Basic[Reprint*2]);
  129.                 WRITE(' ');
  130.               END;  { Reprint basic equivalence with highlight }
  131.               WRITE('    ');
  132.               IF WHEREX + LENGTH(Basic) + (LENGTH(Basic) DIV 2) > 75
  133.               THEN WRITELN;
  134.             END;  { Found a pair }
  135.           END;  { Step through pairs }
  136.         END;  { Step through basic equivalence list }
  137.         IF NOT PairFound THEN WRITELN('No pairs found.');
  138.       END;  { Worth looking for pairs }
  139.       WRITELN;
  140.     END;  { There are digits to consider }
  141.   END;  { Non-null input }
  142. END.